Response Time EDA

Here we take a look at the average response time over time. Two obvious outliers emerge - one on April 7, 2017, and one on August 12, 2017. The latter is obviously the Unite the Right rally that took place in Charlottesville on that date. I'm not yet sure about the April 7 incident - we should ask contacts in Charlottesville if they know why this might be.

## This is going to be at the response unit level, so clean up duplicate individuals and split response times for separate units at single incident
## Outlier spikes on April 7 and August 12 of 2017. August 12 is obviously the Unite the Right rally. Not sure about April 7
new_ems_data %>% 
  clean_response_times() %>%
  group_by(incident_date) %>%
  mutate(avg_response = mean(total_unit_response_time, na.rm = TRUE)) %>%
  ggplot() +
  geom_line(aes(x = incident_date, y = avg_response))

It's curious that it happens on August 12, but that incident still looks like an outlier to me. These spikes are driven by two very long responses, and not because all the calls on that day were abnormally long. Both calls were about 24 hours so I thought it might have to do with an impoperly recorded date (one day ahead or somemthing), but the psap date time and incident date are consistent.

new_ems_data %>% 
  clean_response_times() %>% 
  filter(total_unit_response_time > 1000) %>%
  select(response_incident_number, incident_date, total_unit_response_time, incident_psap_call_date_time)
## # A tibble: 2 x 4
##   response_incident_n… incident_date total_unit_response… incident_psap_call_da…
##   <chr>                <date>                       <dbl> <dttm>                
## 1 2017-00007421        2017-08-12                   1441. 2017-08-12 17:14:36   
## 2 2017-00003319        2017-04-07                   1445. 2017-04-07 18:15:12

Here we have the same thing (with outliers removed) but averaged at the monthly level to see if any longer-term trends emerge. Looks like response times are trending upwards a bit.

## Same thing but grouped by month for clearer sense of trends
new_ems_data %>% 
  filter(total_unit_response_time < 1000) %>%
  clean_response_times() %>%
  group_by(mo_yr) %>%
  mutate(avg_response = mean(total_unit_response_time, na.rm = TRUE)) %>%
  ggplot() +
  geom_line(aes(x = mo_yr, y = avg_response)) +
  labs(title = "Average Total Response Times by Month", y = "Mean Response Time (min)", x = "Date") +
  theme_minimal() +
  plot_theme +
  theme(legend.position = "none")

This is super tentative, but could be an interesting idea: after the pandemic begins, do we see the response times go down for more "concerning" dispatch reports? There's a bit of evidence that maybe response times for complaints of breathing problems and sick people go down while chest pain and falls increase. These are obviously just a tiny subset of complaints, but worth exploring further?

complaints <- select_complaints(4)

## Look at response times by complaint type - might have to just select minimum response time for multi-unit calls to avoid double counting
new_ems_data %>%
  filter(total_unit_response_time < 1000) %>%
  clean_response_times() %>% 
  group_by(response_incident_number) %>%
  filter(!is.na(total_unit_response_time), incident_complaint_reported_by_dispatch %in% complaints) %>%
  mutate(min_total_time = min(total_unit_response_time)) %>%
  ungroup() %>%
  group_by(mo_yr, incident_complaint_reported_by_dispatch) %>%
  mutate(avg_response = mean(as.numeric(total_unit_response_time), na.rm = TRUE)) %>%
  ggplot() +
  geom_line(aes(x = mo_yr, y = avg_response, color = incident_complaint_reported_by_dispatch), alpha = 0.4) +
  geom_smooth(aes(x = mo_yr, y = avg_response, color = incident_complaint_reported_by_dispatch, fill = incident_complaint_reported_by_dispatch), alpha=0.2, show.legend = FALSE) +
  scale_color_manual(values = cbPalette) +
  scale_fill_manual(values = cbPalette) +
  labs(title = "Average Total Response Times by Month: Charlottesville", y = "Mean Response Time (min)", x = "Date", color = "Complaint") +
  guides(color = guide_legend(override.aes = list(alpha = 1))) +
  theme_minimal() #+

  #plot_theme

# ggsave(here("output", "response_times_by_month_top_complaints.png"), height = 10, width = 15)
## Pool incidents by month
monthly_counts <- new_ems_data %>%
  #filter(!is.na(patient_race_list), !str_detect(patient_race_list, ","), patient_race_list != "Not Applicable", patient_race_list != "Not Recorded") %>%
  mutate(age_breaks = cut(as.numeric(patient_age), breaks = c(0, 20, 40, 60, 80, 100))) %>%
  filter(!is.na(age_breaks), yr != "2016") %>%
  group_by(mo_yr, age_breaks) %>%
  count() 

age_baselines <- new_ems_data %>%
  mutate(age_breaks = cut(as.numeric(patient_age), breaks = c(0, 20, 40, 60, 80, 100))) %>%
  group_by(age_breaks, mo_yr) %>%
  filter(incident_date < "2020-03-01", yr != "2016") %>%
  count() %>%
  ungroup() %>%
  group_by(age_breaks) %>%
  summarize(mean = mean(n))
## `summarise()` ungrouping output (override with `.groups` argument)
plot_data <- full_join(monthly_counts, age_baselines) %>% 
  mutate(pct_of_baseline = (n / mean) * 100)
## Joining, by = "age_breaks"
## Plot temporal trends in volume
ggplot(plot_data) + 
  geom_line(aes(x = mo_yr, y = pct_of_baseline, color = age_breaks, group = age_breaks), alpha = 0.7) + 
  geom_point(aes(x = mo_yr, y = pct_of_baseline, color = age_breaks), alpha = 1) +
  geom_vline(xintercept = dmy("02-01-2020"), linetype = "dashed", alpha = 0.8) +
  scale_color_brewer(palette = "YlGnBu") +
  #facet_wrap(~age_breaks, ncol = 1) +
  #labs(x = "Date", y = "Monthly Incidents", color = "Complaint", title = "Call Volume for Top Provider Impressions: Charlottesville\n") +
  theme_minimal() #+
## Warning: Removed 1 row(s) containing missing values (geom_path).
## Warning: Removed 1 rows containing missing values (geom_point).

  #plot_theme